home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue24 / menus / ODMENU2U.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-07-16  |  6.3 KB  |  200 lines
  1. unit ODMenu2U;
  2.  
  3. interface
  4.  
  5. uses
  6.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  7.   Forms, Dialogs, Menus, StdCtrls;
  8.  
  9. type
  10.   TForm1 = class(TForm)
  11.     MainMenu1: TMainMenu;
  12.     Menu1: TMenuItem;
  13.     MenuItem1: TMenuItem;
  14.     MenuItem2: TMenuItem;
  15.     BmpDlg: TOpenDialog;
  16.     Button1: TButton;
  17.     HelpItem1: TMenuItem;
  18.     About1: TMenuItem;
  19.     HowtoUseHelp1: TMenuItem;
  20.     SearchforHelpOn1: TMenuItem;
  21.     Contents1: TMenuItem;
  22.     procedure FormCreate(Sender: TObject);
  23.     procedure FormDestroy(Sender: TObject);
  24.     procedure Button1Click(Sender: TObject);
  25.     procedure MenuItem1Click(Sender: TObject);
  26.     procedure MenuItem2Click(Sender: TObject);
  27.     procedure MenuItem3Click(Sender: TObject);
  28.   private
  29.     PicIndex: Integer;
  30.     ImageList: TImageList;
  31.     Bmp, TransBmp: TBitmap;
  32.     BmpFileName: String;
  33.     procedure WMMeasureItem(var Msg: TWMMeasureItem); message wm_MeasureItem;
  34.     procedure WMDrawItem(var Msg: TWMDrawItem); message wm_DrawItem;
  35.     procedure WMSysColorChange(var Msg: TWMSysColorChange);
  36.       message wm_SysColorChange;
  37.   public
  38.     procedure SetupMenus(const BmpName: String);
  39.   end;
  40.  
  41. var
  42.   Form1: TForm1;
  43.  
  44. implementation
  45.  
  46. {$R *.DFM}
  47.  
  48. { Customise bitmaps at run-time. First is a bitmap menu, }
  49. { the second is fully owner draw, bitmap + its file name }
  50. procedure TForm1.SetupMenus(const BmpName: String);
  51. begin
  52.   Bmp.LoadFromFile(BmpName);
  53.   BmpFileName := BmpName;
  54.   { Destroy and recreate the image list with the new bitmap in }
  55.   if Assigned(ImageList) then
  56.   begin
  57.     ImageList.Free;
  58.     ImageList := nil
  59.   end;
  60. {$ifdef Win32}
  61.   ImageList := TImageList.CreateSize(Bmp.Width, Bmp.Height);
  62. {$else}
  63.   ImageList := TImageList.Create(Bmp.Width, Bmp.Height);
  64. {$endif}
  65.   { Add picture and generate mask }
  66.   TransBmp.Width := Bmp.Width;
  67.   TransBmp.Height := Bmp.Height;
  68.   TransBmp.Canvas.Brush.Color := clMenu;
  69.   TransBmp.Canvas.FillRect(Classes.Rect(0, 0, TransBmp.Width, TransBmp.Height));
  70.   PicIndex := ImageList.AddMasked(Bmp, Bmp.TransparentColor);
  71.   ImageList.Draw(TransBmp.Canvas, 0, 0, PicIndex);
  72.   { First menu item is set to be a bitmap }
  73.   ModifyMenu(Menu1.Handle, MenuItem1.Command,
  74.     mf_ByCommand or mf_Bitmap, MenuItem1.Command, PChar(TransBmp.Handle));
  75.   { Second menu item is set to be an owner draw-menu }
  76.   { So refer to the wm_MeasureItem and wm_DrawItem }
  77.   { message handlers for the details }
  78.   ModifyMenu(Menu1.Handle, MenuItem2.Command,
  79.     mf_ByCommand or mf_OwnerDraw, MenuItem2.Command, PChar(TransBmp));
  80.   DrawMenuBar(Handle);
  81. end;
  82.  
  83. procedure TForm1.FormCreate(Sender: TObject);
  84. begin
  85.   Bmp := TBitmap.Create;
  86.   { Move Help menu over to the right }
  87.   { Windows 95/NT 4 apps support doing it this way ... }
  88.   {$ifndef AlternativeWay}
  89.   ModifyMenu(MainMenu1.Handle, 1, mf_ByPosition or mf_Popup or mf_Help,
  90.     HelpItem1.Handle, '&Help');
  91.   {$else}
  92.   { ... only Win 3.1x supports this }
  93.   HelpItem1.Caption := #8 + HelpItem1.Caption;
  94.   {$endif}
  95.   { Start off with some bitmap }
  96.   SetupMenus('c:\delphi\images\splash\16color\athena.bmp');
  97. end;
  98.  
  99. procedure TForm1.FormDestroy(Sender: TObject);
  100. begin
  101.   Bmp.Free;
  102.   TransBmp.Free;
  103.   ImageList.Free
  104. end;
  105.  
  106. procedure TForm1.WMMeasureItem(var Msg: TWMMeasureItem);
  107. begin
  108.   with Msg, MeasureItemStruct^ do
  109.     if (IDCtl = 0) and (CtlType = odt_Menu) and
  110.        (ItemID = MenuItem2.Command) then
  111.       with TBitmap(ItemData), Canvas do
  112.       begin
  113.         { Width is bitmap width + text width }
  114.         ItemWidth := Width + TextWidth(BmpFileName);
  115.         { Height is Max(bitmap width, text width) }
  116.         if Height > TextHeight(BmpFileName) then
  117.           ItemHeight := Height
  118.         else
  119.           ItemHeight := TextHeight(BmpFileName);
  120.         { Yes, we dealt with this message, all right? }
  121.         LongBool(Result) := True;
  122.       end;
  123. end;
  124.  
  125. procedure TForm1.WMDrawItem(var Msg: TWMDrawItem);
  126. const
  127.   Colors: array[False..True] of TColor = (clMenu, clHighlight);
  128.   TextColors: array[False..True] of TColor = (clMenuText, clHighlightText);
  129.   CopyModes: array[False..True] of TColor = (cmSrcCopy, cmNotSrcCopy);
  130. var
  131.   Rect: TRect;
  132.   SourceBmp: TBitmap;
  133. begin
  134.   with Msg, DrawItemStruct^ do
  135.     if (Ctl = 0) and (CtlType = odt_Menu) and
  136.        (ItemID = MenuItem2.Command) and (HWndItem = Menu1.Handle) then
  137.       with TCanvas.Create do
  138.         try
  139.           SourceBmp := TBitmap(ItemData);
  140.           { Yes, we dealt with this message, all right? }
  141.           LongBool(Result) := True;
  142.           { Map TCanvas over menu DC }
  143.           Handle := hDC;
  144.           { Fill in background with appropriate colour }
  145.           Brush.Color := Colors[ItemState and ods_Selected <> 0];
  146.           FillRect(RCItem);
  147.           { Centre bitmap vertically, in case shorter than the text }
  148.           Rect := Bounds(RCItem.Left,
  149.             (RCItem.Top + RCItem.Bottom - Bmp.Height) div 2,
  150.             SourceBmp.Width, SourceBmp.Height);
  151.           { Draw bitmap, normal or inverted as necessary }
  152.           CopyMode := CopyModes[ItemState and ods_Selected <> 0];
  153.           CopyRect(Rect, SourceBmp.Canvas,
  154.             Classes.Rect(0, 0, SourceBmp.Width, SourceBmp.Height));
  155.           { Set up same font as menus use }
  156.           Font.Size := 8;
  157.           Font.Color := TextColors[ItemState and ods_Selected <> 0];
  158.           { Centre text vertically, in case shorter than the bitmap }
  159.           TextOut(RCItem.Left + SourceBmp.Width,
  160.             (RCItem.Top + RCItem.Bottom - TextHeight(BmpFileName)) div 2,
  161.             BmpFileName);
  162.         finally
  163.           Free
  164.         end;
  165. end;
  166.  
  167. procedure TForm1.WMSysColorChange(var Msg: TWMSysColorChange);
  168. begin
  169.   inherited;
  170.   { When system colour changes, make sure }
  171.   { the bitmap's transparent area is the }
  172.   { same colour as the menu background }
  173.   SetupMenus(BmpFileName)
  174. end;
  175.  
  176. procedure TForm1.Button1Click(Sender: TObject);
  177. begin
  178.   { Button allows menus to be dynamically }
  179.   { changed by picking a new bitmap }
  180.   if BmpDlg.Execute then
  181.     SetupMenus(BmpDlg.FileName);
  182. end;
  183.  
  184. procedure TForm1.MenuItem1Click(Sender: TObject);
  185. begin
  186.   ShowMessage('First menu item');
  187. end;
  188.  
  189. procedure TForm1.MenuItem2Click(Sender: TObject);
  190. begin
  191.   ShowMessage('Second menu item');
  192. end;
  193.  
  194. procedure TForm1.MenuItem3Click(Sender: TObject);
  195. begin
  196.   ShowMessage('Third menu item');
  197. end;
  198.  
  199. end.
  200.